This file sources market_01_data_prep.Rmd to load all
cleaned BLS data into memory. Make sure File 1 is in the same directory
as this file.
source(knitr::purl("market_01_data_prep.Rmd", output = tempfile(), quiet = TRUE))
## Programs tracked: 9
## Unique SOC codes: 9
## SOC codes: 29-1127, 29-1181, 29-9021, 29-1122, 29-1123, 29-1071, 29-9091, 29-1031, 29-1128
## All-occupations projected growth (latest cycle): 3.1 %
## Labor force projected growth 2024-34: 3.2 %
## Industry: NAICS 621990 — All Other Misc Ambulatory Health Care
## Total industry employment 2024: 187.4 thousand
## Projected 2034: 207.5 thousand
## Growth: 10.7 %
##
## SHRS occupations FOUND in this industry:
##
## # A tibble: 6 × 6
## shrs_program occupation_title emp_2024 emp_2034 pct_change pct_of_occ
## <chr> <chr> <dbl> <dbl> <dbl> <dbl>
## 1 DN Dietitians and nutrition… 0.1 0.1 10.6 0.1
## 2 PAS Physician assistants 1.1 1.2 10.6 0.6
## 3 DPT Physical therapists 0.1 0.1 10.6 0
## 4 SS Exercise physiologists 0.5 0.6 10.6 2.1
## 5 AuD Audiologists 0.2 0.2 10.6 1
## 6 HIM Health information techn… 0.9 1.1 21.7 2.2
##
## SHRS SOC codes NOT in this industry: 29-1127, 29-1122, 29-9091
## (These occupations are concentrated in other industries)
library(scales)
library(tidyverse)
library(kableExtra)
How has employment in SHRS-related occupations changed over the past several years? Are these fields growing, shrinking, or stagnant?
oews |>
ggplot(aes(x = year, y = tot_emp, color = shrs_program)) +
geom_line(linewidth = 1.2) +
geom_point(size = 2.5) +
facet_wrap(~ shrs_program, scales = "free_y", ncol = 3) +
scale_y_continuous(labels = comma) +
scale_x_continuous(breaks = unique(oews$year)) +
labs(
title = "National Employment Trends by SHRS Occupation",
subtitle = "Source: BLS Occupational Employment and Wage Statistics (OEWS)",
x = NULL, y = "Total Employment"
) +
theme_minimal(base_size = 13) +
theme(legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1))
emp_growth <- oews |>
group_by(shrs_program, occ_title) |>
summarise(
emp_first_year = first(tot_emp),
emp_last_year = last(tot_emp),
year_start = min(year),
year_end = max(year),
abs_change = last(tot_emp) - first(tot_emp),
pct_change = round((last(tot_emp) / first(tot_emp) - 1) * 100, 1),
.groups = "drop"
) |>
arrange(desc(pct_change))
emp_growth |>
select(Program = shrs_program, Occupation = occ_title,
`Start Emp` = emp_first_year, `End Emp` = emp_last_year,
`Change` = abs_change, `Growth (%)` = pct_change) |>
kable(format.args = list(big.mark = ",")) |>
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
| Program | Occupation | Start Emp | End Emp | Change | Growth (%) |
|---|---|---|---|---|---|
| PAS | Physician Assistants | 91,670 | 155,540 | 63,870 | 69.7 |
| SLP | Speech-Language Pathologists | 126,500 | 178,790 | 52,290 | 41.3 |
| OTD | Occupational Therapists | 110,520 | 152,280 | 41,760 | 37.8 |
| AT | Athletic Trainers | 22,400 | 28,950 | 6,550 | 29.2 |
| DN | Dietitians and Nutritionists | 59,490 | 76,570 | 17,080 | 28.7 |
| DPT | Physical Therapists | 200,670 | 248,630 | 47,960 | 23.9 |
| SS | Exercise Physiologists | 6,660 | 8,110 | 1,450 | 21.8 |
| AuD | Audiologists | 12,250 | 14,730 | 2,480 | 20.2 |
| HIM | Health Information Technologists and Medical Registrars | 37,900 | 37,620 | -280 | -0.7 |
oews |>
ggplot(aes(x = year, y = a_median, color = shrs_program)) +
geom_line(linewidth = 1.2) +
geom_point(size = 2.5) +
facet_wrap(~ shrs_program, scales = "free_y", ncol = 3) +
scale_y_continuous(labels = dollar) +
scale_x_continuous(breaks = unique(oews$year)) +
labs(
title = "Median Annual Wage Trends by SHRS Occupation",
subtitle = "Source: BLS OEWS",
x = NULL, y = "Median Annual Wage"
) +
theme_minimal(base_size = 13) +
theme(legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1))
latest_year <- max(oews$year)
oews |>
filter(year == latest_year) |>
ggplot(aes(x = reorder(shrs_program, a_median), y = a_median, fill = shrs_dept)) +
geom_col(width = 0.6) +
geom_text(aes(label = dollar(a_median)), hjust = -0.1, size = 4) +
coord_flip() +
scale_y_continuous(labels = dollar, expand = expansion(mult = c(0, 0.2))) +
labs(
title = paste0("Median Annual Wage by SHRS Occupation (", latest_year, ")"),
subtitle = "Source: BLS OEWS",
x = NULL, y = "Median Annual Wage", fill = "Department"
) +
theme_minimal(base_size = 13)
projections |>
ggplot(aes(x = cycle, y = emp_change_pct, fill = shrs_program)) +
geom_col(position = "dodge", width = 0.7) +
geom_hline(yintercept = all_occ_growth_pct, linetype = "dashed",
color = "gray40", linewidth = 0.7) +
annotate("text", x = 1, y = all_occ_growth_pct + 1,
label = paste0("All occupations: ", all_occ_growth_pct, "%"),
hjust = 0, size = 3.5, color = "gray40") +
facet_wrap(~ shrs_program, ncol = 3, scales = "free_y") +
labs(
title = "BLS Projected Employment Growth (%) Across Projection Cycles",
subtitle = "Dashed line = all-occupations benchmark from latest cycle",
x = "Projection Cycle", y = "Projected Growth (%)"
) +
theme_minimal(base_size = 13) +
theme(legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1))
proj_latest <- projections |>
filter(base_year == max(base_year))
proj_latest |>
mutate(
vs_benchmark = round(emp_change_pct - all_occ_growth_pct, 1),
signal = case_when(
emp_change_pct >= all_occ_growth_pct * 2 ~ "Strong Growth",
emp_change_pct >= all_occ_growth_pct ~ "Above Average",
emp_change_pct >= 0 ~ "Below Average",
TRUE ~ "Declining"
)
) |>
select(Program = shrs_program, Cycle = cycle,
`Base Emp (000s)` = emp_base, `Proj Emp (000s)` = emp_projected,
`Growth (%)` = emp_change_pct, `vs All Occ (pp)` = vs_benchmark,
Signal = signal, `Openings/yr (000s)` = annual_openings,
`Median Wage` = median_wage) |>
kable(format.args = list(big.mark = ",")) |>
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
| Program | Cycle | Base Emp (000s) | Proj Emp (000s) | Growth (%) | vs All Occ (pp) | Signal | Openings/yr (000s) | Median Wage |
|---|---|---|---|---|---|---|---|---|
| DN | 2024-2034 | 90.9 | 95.9 | 5.5 | 2.4 | Above Average | 6.2 | 73,850 |
| PAS | 2024-2034 | 162.7 | 195.8 | 20.4 | 17.3 | Strong Growth | 12.0 | 133,260 |
| OTD | 2024-2034 | 160.0 | 182.1 | 13.8 | 10.7 | Strong Growth | 10.2 | 98,340 |
| DPT | 2024-2034 | 267.2 | 296.4 | 10.9 | 7.8 | Strong Growth | 13.2 | 101,020 |
| SLP | 2024-2034 | 187.4 | 215.5 | 15.0 | 11.9 | Strong Growth | 13.3 | 95,410 |
| SS | 2024-2034 | 23.9 | 26.1 | 9.5 | 6.4 | Strong Growth | 1.7 | 58,160 |
| AuD | 2024-2034 | 15.8 | 17.3 | 9.5 | 6.4 | Strong Growth | 0.7 | 92,120 |
| HIM | 2024-2034 | 41.9 | 48.1 | 14.7 | 11.6 | Strong Growth | 3.2 | 67,310 |
| AT | 2024-2034 | 33.9 | 37.6 | 11.1 | 8.0 | Strong Growth | 2.4 | 60,250 |
Job openings come from two sources: growth (new positions created) and replacement (people leaving through retirement, career changes, etc.). Even slow-growth occupations can have strong demand if turnover is high.
sep_long <- separations |>
select(shrs_program, lf_exits, occ_transfers, emp_change_numeric) |>
rename(`Labor Force Exits` = lf_exits,
`Occupational Transfers` = occ_transfers,
`Growth` = emp_change_numeric) |>
pivot_longer(-shrs_program, names_to = "component", values_to = "value")
sep_long |>
ggplot(aes(x = reorder(shrs_program, value, sum), y = value, fill = component)) +
geom_col(width = 0.6) +
coord_flip() +
scale_fill_manual(values = c("Growth" = "#2c7bb6",
"Labor Force Exits" = "#d7191c",
"Occupational Transfers" = "#fdae61")) +
labs(title = "Components of Annual Job Openings by SHRS Occupation",
subtitle = "Latest BLS projection cycle (thousands per year)",
x = NULL, y = "Annual Openings (thousands)", fill = NULL) +
theme_minimal(base_size = 13) +
theme(legend.position = "bottom")
separations |>
select(Program = shrs_program, `Exit Rate (%)` = lf_exit_rate,
`Transfer Rate (%)` = occ_transfer_rate,
`Total Sep Rate (%)` = total_sep_rate,
`Annual Openings (000s)` = annual_openings) |>
kable() |>
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
| Program | Exit Rate (%) | Transfer Rate (%) | Total Sep Rate (%) | Annual Openings (000s) |
|---|---|---|---|---|
| DN | 3.3 | 2.8 | 6.1 | 6.2 |
| PAS | 2.0 | 2.8 | 4.9 | 12.0 |
| OTD | 2.2 | 2.4 | 4.7 | 10.2 |
| DPT | 2.1 | 1.5 | 3.7 | 13.2 |
| SLP | 2.6 | 2.6 | 5.2 | 13.3 |
| SS | 3.0 | 2.8 | 5.8 | 1.7 |
| AuD | 2.4 | 0.9 | 3.2 | 0.7 |
| HIM | 3.0 | 2.8 | 5.8 | 3.2 |
| AT | 3.0 | 2.8 | 5.8 | 2.4 |
benchmark_df <- proj_latest |>
select(shrs_program, emp_change_pct) |>
bind_rows(
tibble(shrs_program = "All Occupations", emp_change_pct = all_occ_growth_pct),
tibble(shrs_program = "Labor Force", emp_change_pct = lf_growth_2024_2034)
) |>
mutate(is_benchmark = shrs_program %in% c("All Occupations", "Labor Force"),
fill_color = if_else(is_benchmark, "Benchmark", "SHRS Program"))
benchmark_df |>
ggplot(aes(x = reorder(shrs_program, emp_change_pct),
y = emp_change_pct, fill = fill_color)) +
geom_col(width = 0.6) +
geom_text(aes(label = paste0(emp_change_pct, "%")), hjust = -0.1, size = 4) +
coord_flip() +
scale_fill_manual(values = c("SHRS Program" = "#2c7bb6", "Benchmark" = "#cccccc")) +
scale_y_continuous(expand = expansion(mult = c(0, 0.2))) +
labs(title = "Projected Employment Growth: SHRS Occupations vs Benchmarks",
subtitle = paste0("Latest BLS cycle (", proj_latest$cycle[1], ")"),
x = NULL, y = "Projected Growth (%)", fill = NULL) +
theme_minimal(base_size = 13) +
theme(legend.position = "bottom")
healthcare_row <- industry |>
filter(str_detect(industry_sector, regex("health care|healthcare", ignore_case = TRUE)))
if (nrow(healthcare_row) > 0) {
ind_cols <- names(industry)
emp_cols <- str_which(ind_cols, "employment")
healthcare_summary <- healthcare_row |>
select(industry_sector, all_of(ind_cols[emp_cols]))
healthcare_summary |>
kable(format.args = list(big.mark = ",")) |>
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
}
| industry_sector | employment_2014 | employment_2024 | employment_2034 | employment_change_numeric_2014_24 | employment_change_numeric_2024_34 | employment_change_percent_2014_24 | employment_change_percent_2024_34 |
|---|---|---|---|---|---|---|---|
| Healthcare and social assistance; private | 18,022.5 | 22,527.4 | 24,489.1 | 4,504.9 | 1,961.7 | 25 | 8.7 |
lf_summary |>
kable() |>
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
| metric | value |
|---|---|
| Labor Force 2004 (thousands) | 147402.0 |
| Labor Force 2014 (thousands) | 155922.0 |
| Labor Force 2024 (thousands) | 168104.0 |
| Labor Force 2034 (thousands) | 173454.0 |
| Growth 2014-24 (%) | 7.8 |
| Growth 2024-34 (%) | 3.2 |
Does the degree Pitt confers match what the labor market expects? We compare three things for each program:
edu_req_dedup <- edu_requirements_shrs |>
distinct(soc_code, .keep_all = TRUE) |>
select(soc_code, bls_entry_education = typical_entry_education, ojt = ojt_required)
edu_att_dedup <- edu_attainment_shrs |>
distinct(soc_code, .keep_all = TRUE) |>
select(soc_code, bachelors, masters, doctoral)
credential_alignment <- soc_crosswalk |>
select(shrs_program, shrs_dept, soc_code, pitt_degree) |>
left_join(edu_req_dedup, by = "soc_code") |>
left_join(edu_att_dedup, by = "soc_code") |>
mutate(
pitt_degree_group = case_when(
str_detect(pitt_degree, "Doctoral|Post-Professional") ~ "doctoral",
TRUE ~ "masters"
),
workforce_pct_at_pitt_level = case_when(
pitt_degree_group == "doctoral" ~ doctoral,
pitt_degree_group == "masters" ~ masters,
TRUE ~ NA_real_
),
bls_requires_group = case_when(
str_detect(bls_entry_education, regex("doctoral|professional", ignore_case = TRUE)) ~ "doctoral",
str_detect(bls_entry_education, regex("master", ignore_case = TRUE)) ~ "masters",
str_detect(bls_entry_education, regex("bachelor", ignore_case = TRUE)) ~ "bachelors",
TRUE ~ "other"
),
credential_match = case_when(
pitt_degree_group == bls_requires_group ~ "Aligned",
pitt_degree_group == "doctoral" & bls_requires_group == "masters" ~ "Above Required",
pitt_degree_group == "masters" & bls_requires_group == "bachelors" ~ "Above Required",
pitt_degree_group == "masters" & bls_requires_group == "doctoral" ~ "Below Required",
pitt_degree_group == "masters" & bls_requires_group == "other" ~ "Above Required",
TRUE ~ "Review"
)
)
credential_alignment |>
select(Program = shrs_program, Dept = shrs_dept,
`Pitt Awards` = pitt_degree, `BLS Requires` = bls_entry_education,
`Match` = credential_match,
`% Workforce at Pitt Level` = workforce_pct_at_pitt_level,
`% Bachelor's` = bachelors, `% Master's` = masters,
`% Doctoral+` = doctoral) |>
kable(digits = 1) |>
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
| Program | Dept | Pitt Awards | BLS Requires | Match | % Workforce at Pitt Level | % Bachelor’s | % Master’s | % Doctoral+ |
|---|---|---|---|---|---|---|---|---|
| SLP | CSD | Master’s | Master’s degree | Aligned | 82.5 | 10.9 | 82.5 | 3.7 |
| AuD | CSD | Doctoral | Doctoral or professional degree | Aligned | 70.7 | 8.1 | 15.5 | 70.7 |
| HIM | HIM | Master’s | Associate’s degree | Above Required | 34.9 | 30.8 | 34.9 | 6.5 |
| OTD | OT | Doctoral | Master’s degree | Above Required | 11.5 | 29.6 | 54.5 | 11.5 |
| DPT | PT | Doctoral | Doctoral or professional degree | Aligned | 53.3 | 23.2 | 18.0 | 53.3 |
| PAS | PAS | Master’s | Master’s degree | Aligned | 61.5 | 17.2 | 61.5 | 14.5 |
| AT | SMN | Master’s | Master’s degree | Aligned | 34.9 | 30.8 | 34.9 | 6.5 |
| DN | SMN | Master’s | Bachelor’s degree | Above Required | 35.4 | 36.8 | 35.4 | 6.8 |
| SS | SMN | Master’s | Bachelor’s degree | Above Required | 61.3 | 21.3 | 61.3 | 6.3 |
cred_long <- credential_alignment |>
select(shrs_program, bachelors, masters, doctoral) |>
pivot_longer(-shrs_program, names_to = "degree_level", values_to = "pct") |>
mutate(degree_level = factor(degree_level,
levels = c("bachelors", "masters", "doctoral"),
labels = c("Bachelor's", "Master's", "Doctoral+")))
pitt_markers <- credential_alignment |>
select(shrs_program, pitt_degree_group, workforce_pct_at_pitt_level) |>
mutate(degree_level = factor(
case_when(pitt_degree_group == "doctoral" ~ "Doctoral+", TRUE ~ "Master's"),
levels = c("Bachelor's", "Master's", "Doctoral+")))
cred_long |>
ggplot(aes(x = degree_level, y = pct, fill = degree_level)) +
geom_col(width = 0.6) +
geom_point(data = pitt_markers,
aes(x = degree_level, y = workforce_pct_at_pitt_level),
shape = 18, size = 5, color = "red", inherit.aes = FALSE) +
facet_wrap(~ shrs_program, ncol = 3) +
scale_fill_manual(values = c("Bachelor's" = "#fdae61",
"Master's" = "#2c7bb6",
"Doctoral+" = "#1a9641")) +
labs(title = "Workforce Education Distribution by SHRS Occupation",
subtitle = "Red diamond = degree level Pitt awards (Table 5.3, 2022–23 CPS)",
x = NULL, y = "% of Workers", fill = NULL) +
theme_minimal(base_size = 12) +
theme(legend.position = "bottom",
axis.text.x = element_text(angle = 30, hjust = 1))
credential_scores <- credential_alignment |>
mutate(
credential_score = case_when(
credential_match == "Aligned" & workforce_pct_at_pitt_level >= 60 ~ 5,
credential_match == "Aligned" & workforce_pct_at_pitt_level >= 40 ~ 4,
credential_match == "Aligned" ~ 3,
credential_match == "Above Required" & workforce_pct_at_pitt_level >= 30 ~ 3,
credential_match == "Above Required" ~ 2,
credential_match == "Below Required" ~ 1,
TRUE ~ 0
)
)
credential_scores |>
select(Program = shrs_program, `Pitt Awards` = pitt_degree,
`BLS Requires` = bls_entry_education,
`Match Status` = credential_match,
`Workforce %` = workforce_pct_at_pitt_level,
`Score (0-5)` = credential_score) |>
arrange(desc(`Score (0-5)`)) |>
kable(digits = 1) |>
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
| Program | Pitt Awards | BLS Requires | Match Status | Workforce % | Score (0-5) |
|---|---|---|---|---|---|
| SLP | Master’s | Master’s degree | Aligned | 82.5 | 5 |
| AuD | Doctoral | Doctoral or professional degree | Aligned | 70.7 | 5 |
| PAS | Master’s | Master’s degree | Aligned | 61.5 | 5 |
| DPT | Doctoral | Doctoral or professional degree | Aligned | 53.3 | 4 |
| HIM | Master’s | Associate’s degree | Above Required | 34.9 | 3 |
| AT | Master’s | Master’s degree | Aligned | 34.9 | 3 |
| DN | Master’s | Bachelor’s degree | Above Required | 35.4 | 3 |
| SS | Master’s | Bachelor’s degree | Above Required | 61.3 | 3 |
| OTD | Doctoral | Master’s degree | Above Required | 11.5 | 2 |
This section examines SHRS occupations within one specific industry slice: NAICS 621990 (All Other Miscellaneous Ambulatory Health Care Services). This is a relatively small industry (187K total jobs in 2024), so most SHRS occupations have minimal presence here. The value of this analysis is understanding which occupations are present and how the broader ambulatory care sector is growing.
For the overall healthcare industry context (22.5 million jobs, 8.7% projected growth), see Section 4.2 above.
if (nrow(ind_matrix_shrs) > 0) {
cat("*Note: Employment figures are in thousands. Most SHRS occupations have*
*small presence in this specific sub-industry, reflecting industry diversification —*
*SHRS graduates work across many sectors.*\n\n")
ind_matrix_shrs |>
select(Program = shrs_program, Occupation = occupation_title,
`2024 Emp (000s)` = x2024_employment,
`2034 Proj (000s)` = projected_2034_employment,
`Growth (%)` = employment_percent_change_2024_2034,
`% of Industry` = x2024_percent_of_industry,
`% of Occupation` = x2024_percent_of_occupation) |>
kable(digits = 1) |>
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE) |>
cat()
} else {
cat("No SHRS occupations found in this industry matrix.\n")
}
Note: Employment figures are in thousands. Most SHRS occupations have small presence in this specific sub-industry, reflecting industry diversification — SHRS graduates work across many sectors.
| Program | Occupation | 2024 Emp (000s) | 2034 Proj (000s) | Growth (%) | % of Industry | % of Occupation |
|---|---|---|---|---|---|---|
| DN | Dietitians and nutritionists | 0.1 | 0.1 | 10.6 | 0.1 | 0.1 |
| PAS | Physician assistants | 1.1 | 1.2 | 10.6 | 0.6 | 0.6 |
| DPT | Physical therapists | 0.1 | 0.1 | 10.6 | 0.0 | 0.0 |
| SS | Exercise physiologists | 0.5 | 0.6 | 10.6 | 0.3 | 2.1 |
| AuD | Audiologists | 0.2 | 0.2 | 10.6 | 0.1 | 1.0 |
| HIM | Health information technologists and medical registrars | 0.9 | 1.1 | 21.7 | 0.5 | 2.2 |
if (nrow(ind_matrix_shrs) > 0) {
ind_matrix_shrs |>
ggplot(aes(x = reorder(shrs_program, x2024_percent_of_occupation),
y = x2024_percent_of_occupation)) +
geom_col(fill = "#2c7bb6", width = 0.6) +
geom_text(aes(label = paste0(round(x2024_percent_of_occupation, 1), "%")),
hjust = -0.1, size = 4) +
coord_flip() +
scale_y_continuous(expand = expansion(mult = c(0, 0.3))) +
labs(title = "Share of Occupation in Ambulatory Care (NAICS 621990)",
subtitle = "What % of each occupation's total national employment is in this sub-industry",
x = NULL, y = "% of Total Occupation Employment") +
theme_minimal(base_size = 13)
}
missing_programs <- soc_crosswalk |>
filter(soc_code %in% socs_missing) |>
select(Program = shrs_program, Occupation = occupation_title, `SOC Code` = soc_code)
if (nrow(missing_programs) > 0) {
cat("The following SHRS occupations are **not present** in NAICS 621990.
This indicates these occupations are distributed across other industries
(education, hospitals, physician offices, sports organizations, etc.).
Industry diversification is generally a positive signal for employment stability.\n\n")
missing_programs |>
kable() |>
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE) |>
cat()
}
The following SHRS occupations are not present in NAICS 621990. This indicates these occupations are distributed across other industries (education, hospitals, physician offices, sports organizations, etc.). Industry diversification is generally a positive signal for employment stability.
| Program | Occupation | SOC Code |
|---|---|---|
| SLP | Speech-Language Pathologists | 29-1127 |
| OTD | Occupational Therapists | 29-1122 |
| AT | Athletic Trainers | 29-9091 |
For context, what are the fastest-growing occupations in this industry alongside SHRS programs?
ind_matrix |>
filter(occupation_type == "Line Item",
!is.na(employment_percent_change_2024_2034)) |>
slice_max(employment_percent_change_2024_2034, n = 15) |>
mutate(
is_shrs = occupation_code %in% target_socs,
label = if_else(is_shrs, paste0(occupation_title, " *"), occupation_title)
) |>
ggplot(aes(x = reorder(label, employment_percent_change_2024_2034),
y = employment_percent_change_2024_2034, fill = is_shrs)) +
geom_col(width = 0.6) +
coord_flip() +
scale_fill_manual(values = c("FALSE" = "#cccccc", "TRUE" = "#2c7bb6"),
labels = c("Other", "SHRS"), name = NULL) +
labs(title = "Top 15 Fastest-Growing Occupations in NAICS 621990",
subtitle = "SHRS-related occupations marked with asterisk",
x = NULL, y = "Projected Growth 2024-2034 (%)") +
theme_minimal(base_size = 11) +
theme(legend.position = "bottom")
This is the synthesis: for each SHRS program, we combine historical trends, forward projections, wage levels, job openings, and credential alignment into an overall market demand assessment.
Scoring: 6 dimensions, normalized to a 0–100 scale for intuitive interpretation. Raw composite is out of 20, then scaled to 100.
# Education premium scores
edu_premium_scores <- credential_alignment |>
mutate(
edu_premium_score = case_when(
pitt_degree_group == "doctoral" ~ 3,
pitt_degree_group == "masters" ~ 2,
TRUE ~ 1
)
) |>
select(shrs_program, edu_premium_score)
# Build scorecard components
proj_for_scorecard <- proj_latest |>
select(soc_code, emp_change_pct, annual_openings, median_wage) |>
distinct(soc_code, .keep_all = TRUE)
sep_for_scorecard <- separations |>
select(soc_code, total_sep_rate) |>
distinct(soc_code, .keep_all = TRUE)
growth_for_scorecard <- emp_growth |>
left_join(soc_crosswalk |> select(shrs_program, soc_code), by = "shrs_program") |>
select(soc_code, historical_growth_pct = pct_change) |>
distinct(soc_code, .keep_all = TRUE)
scorecard <- soc_crosswalk |>
select(shrs_program, shrs_dept, soc_code) |>
left_join(proj_for_scorecard, by = "soc_code") |>
left_join(growth_for_scorecard, by = "soc_code") |>
left_join(sep_for_scorecard, by = "soc_code") |>
left_join(credential_scores |> select(shrs_program, credential_score, credential_match),
by = "shrs_program") |>
left_join(edu_premium_scores, by = "shrs_program") |>
mutate(
# Dimension 1: Projected Growth (0-3)
growth_score = case_when(
emp_change_pct >= all_occ_growth_pct * 2 ~ 3,
emp_change_pct >= all_occ_growth_pct ~ 2,
emp_change_pct >= 0 ~ 1,
TRUE ~ 0
),
# Dimension 2: Wage Level (0-3)
wage_score = case_when(
median_wage >= 90000 ~ 3,
median_wage >= 60000 ~ 2,
median_wage >= 40000 ~ 1,
TRUE ~ 0
),
# Dimension 3: Annual Openings (0-3)
openings_score = case_when(
annual_openings >= 10 ~ 3,
annual_openings >= 3 ~ 2,
annual_openings >= 1 ~ 1,
TRUE ~ 0
),
# Dimension 4: Replacement Demand (0-3)
turnover_score = case_when(
total_sep_rate >= 6 ~ 3,
total_sep_rate >= 4 ~ 2,
total_sep_rate >= 2 ~ 1,
TRUE ~ 0
),
# Dimensions 5-6: credential_score (0-5) and edu_premium_score (0-3)
# Raw composite (max 20)
raw_score = growth_score + wage_score + openings_score +
turnover_score + credential_score + edu_premium_score,
# Scaled to 0-100
composite_score = round(raw_score / 20 * 100),
# Signal based on 0-100 scale
market_signal = case_when(
composite_score >= 80 ~ "Strong",
composite_score >= 60 ~ "Favorable",
composite_score >= 40 ~ "Moderate",
composite_score >= 20 ~ "Weak",
TRUE ~ "Critical"
)
)
scorecard |>
select(Program = shrs_program, Dept = shrs_dept,
`Hist Growth (%)` = historical_growth_pct,
`Proj Growth (%)` = emp_change_pct,
`Median Wage` = median_wage,
`Openings/yr (000s)` = annual_openings,
`Sep Rate (%)` = total_sep_rate,
`Cred Match` = credential_match,
`Score (0-100)` = composite_score,
Signal = market_signal) |>
arrange(desc(`Score (0-100)`)) |>
kable(format.args = list(big.mark = ",")) |>
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
| Program | Dept | Hist Growth (%) | Proj Growth (%) | Median Wage | Openings/yr (000s) | Sep Rate (%) | Cred Match | Score (0-100) | Signal |
|---|---|---|---|---|---|---|---|---|---|
| SLP | CSD | 41.3 | 15.0 | 95,410 | 13.3 | 5.2 | Aligned | 90 | Strong |
| PAS | PAS | 69.7 | 20.4 | 133,260 | 12.0 | 4.9 | Aligned | 90 | Strong |
| DPT | PT | 23.9 | 10.9 | 101,020 | 13.2 | 3.7 | Aligned | 85 | Strong |
| OTD | OT | 37.8 | 13.8 | 98,340 | 10.2 | 4.7 | Above Required | 80 | Strong |
| AuD | CSD | 20.2 | 9.5 | 92,120 | 0.7 | 3.2 | Aligned | 75 | Favorable |
| HIM | HIM | -0.7 | 14.7 | 67,310 | 3.2 | 5.8 | Above Required | 70 | Favorable |
| DN | SMN | 28.7 | 5.5 | 73,850 | 6.2 | 6.1 | Above Required | 70 | Favorable |
| AT | SMN | 29.2 | 11.1 | 60,250 | 2.4 | 5.8 | Aligned | 65 | Favorable |
| SS | SMN | 21.8 | 9.5 | 58,160 | 1.7 | 5.8 | Above Required | 60 | Favorable |
scorecard |>
transmute(shrs_program,
`Growth (0-3)` = growth_score,
`Wage (0-3)` = wage_score,
`Openings (0-3)` = openings_score,
`Replacement (0-3)` = turnover_score,
`Credential (0-5)` = credential_score,
`Edu Premium (0-3)` = edu_premium_score) |>
pivot_longer(-shrs_program, names_to = "dimension", values_to = "score") |>
mutate(max_score = case_when(str_detect(dimension, "0-5") ~ 5, TRUE ~ 3)) |>
ggplot(aes(x = dimension, y = score, fill = dimension)) +
geom_col(width = 0.7) +
facet_wrap(~ shrs_program, ncol = 3) +
scale_y_continuous(limits = c(0, 5), breaks = 0:5) +
labs(title = "Market Demand Scorecard Decomposition by SHRS Program",
subtitle = "Each dimension scored individually; composite normalized to 0-100",
x = NULL, y = "Score") +
theme_minimal(base_size = 11) +
theme(legend.position = "none",
axis.text.x = element_text(angle = 55, hjust = 1))
This maps each program to the red-yellow-green color spectrum that will drive the final Program Health Dashboard.
scorecard |>
ggplot(aes(x = reorder(shrs_program, composite_score),
y = composite_score, fill = composite_score / 100)) +
geom_col(width = 0.6) +
geom_text(aes(label = paste0(composite_score, "/100")), hjust = -0.1, size = 4) +
coord_flip() +
scale_fill_gradientn(
colors = c("#d73027", "#fdae61", "#fee08b", "#a6d96a", "#1a9641"),
values = c(0, 0.25, 0.5, 0.75, 1),
limits = c(0, 1), name = "Health\nSignal") +
scale_y_continuous(limits = c(0, 115), expand = expansion(mult = c(0, 0))) +
labs(title = "Program Market Health Signal — Dashboard Preview",
subtitle = "Red-to-Green | Based on 6-dimension composite (0-100 scale)",
x = NULL, y = "Composite Market Score (0-100)") +
theme_minimal(base_size = 13) +
theme(legend.position = "right")
for (i in seq_len(nrow(scorecard))) {
row <- scorecard[i, ]
cat(paste0("\n## ", row$shrs_program, " — ", row$market_signal, "\n\n"))
cat(paste0("- **Projected growth**: ", row$emp_change_pct,
"% (vs ", all_occ_growth_pct, "% all occupations)\n"))
if (!is.na(row$historical_growth_pct)) {
cat(paste0("- **Historical growth**: ", row$historical_growth_pct,
"% (OEWS ", min(oews$year), "-", max(oews$year), ")\n"))
}
cat(paste0("- **Median wage**: $", format(row$median_wage, big.mark = ","), "\n"))
cat(paste0("- **Annual openings**: ",
format(row$annual_openings * 1000, big.mark = ","), "\n"))
if (!is.na(row$total_sep_rate)) {
cat(paste0("- **Separation rate**: ", row$total_sep_rate, "%\n"))
}
cat(paste0("- **Credential alignment**: ", row$credential_match,
" (score: ", row$credential_score, "/5)\n"))
cat(paste0("- **Composite score**: ", row$composite_score, "/100\n\n"))
}
Data Sources:
Scorecard Methodology (v2.1):
Six dimensions, raw max = 20, normalized to 0-100 scale:
| Dimension | 0 | 1 | 2 | 3 | 4 | 5 |
|---|---|---|---|---|---|---|
| Projected Growth | Declining | 0-3.1% | 3.1-6.2% | >6.2% | — | — |
| Wage Level | <$40K | $40-60K | $60-90K | >$90K | — | — |
| Annual Openings | <1K | 1-3K | 3-10K | >10K | — | — |
| Replacement Demand | <2% | 2-4% | 4-6% | >6% | — | — |
| Education Premium | Other | — | Master’s tier | Doctoral tier | — | — |
| Credential Alignment | Review | Below Req | Above (low %) | Above/Aligned (med %) | Aligned (high %) | Perfect |
Dashboard Color Mapping:
| Score Range | Color | Signal |
|---|---|---|
| 80-100 | Dark Green | Strong |
| 60-79 | Light Green | Favorable |
| 40-59 | Yellow | Moderate |
| 20-39 | Orange | Weak |
| 0-19 | Red | Critical |
Known Limitations: